home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / overlay.el.z / overlay.el
Encoding:
Text File  |  1998-05-21  |  8.8 KB  |  244 lines
  1. ;;; overlay.el --- overlay support.
  2.  
  3. ;;;; Copyright (C) 1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Joe Nuspl <nuspl@sequent.com>
  6. ;; Maintainer: XEmacs Development Team (in <hniksic@srce.hr> incarnation)
  7. ;; Keywords: internal
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Synched up with: Not in FSF.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; Unlike the text-properties interface, these functions are in fact
  31. ;; totally useless in XEmacs.  They are a more or less straightforward
  32. ;; interface to the much better extent API, provided exclusively for
  33. ;; GNU Emacs compatibility.  If you notice an incompatibility not
  34. ;; mentioned below, be sure to mention it.  Anyways, you should really
  35. ;; not use this.
  36.  
  37. ;; Known incompatibilities with the FSF interface:
  38.  
  39. ;; 1. There is not an `overlay' type.  Any extent with non-nil
  40. ;;    'overlay property is considered an "overlay".
  41. ;;
  42. ;; 2. Some features of FSF overlays have not been implemented in
  43. ;;    extents (or are unneeded).  Specifically, those are the
  44. ;;    following special properties: window, insert-in-front-hooks,
  45. ;;    insert-behind-hooks, and modification-hooks.  Some of these will
  46. ;;    probably be implemented for extents in the future.
  47. ;;
  48. ;; 3. In FSF, beginning and end of an overlay are markers, which means
  49. ;;    that you can use `insert-before-markers' to change insertion
  50. ;;    property of overlay.  It will not work in this emulation, and we
  51. ;;    have no plans of providing it.
  52. ;;
  53. ;; 4. The `overlays-in' and `overlays-at' functions in some cases
  54. ;;    don't work as they should.  To be fixed RSN.
  55. ;;
  56. ;; 5. Finally, setting or modification of overlay properties specific
  57. ;;    to extents will have unusual results.  While (overlay-put
  58. ;;    overlay 'start-open t) does nothing under FSF, it has a definite
  59. ;;    effect under XEmacs.  This is solved by simply avoiding such
  60. ;;    names (see `set-extent-property' for a list).
  61.  
  62. ;; Some functions were broken; fixed-up by Hrvoje Niksic, June 1997.
  63.  
  64.  
  65. ;;; Code:
  66.  
  67. (defun overlayp (object)
  68.   "Return t if OBJECT is an overlay."
  69.   (and (extentp object)
  70.        (extent-property object 'overlay)))
  71.  
  72. (defun make-overlay (beg end &optional buffer front-advance rear-advance)
  73.   "Create a new overlay with range BEG to END in BUFFER.
  74. If omitted, BUFFER defaults to the current buffer.
  75. BEG and END may be integers or markers.
  76. The fourth arg FRONT-ADVANCE, if non-nil, makes the
  77. front delimiter advance when text is inserted there.
  78. The fifth arg REAR-ADVANCE, if non-nil, makes the
  79. rear delimiter advance when text is inserted there."
  80.   (if (null buffer)
  81.       (setq buffer (current-buffer))
  82.     (check-argument-type 'bufferp buffer))
  83.   (when (> beg end)
  84.     (setq beg (prog1 end (setq end beg))))
  85.  
  86.   (let ((overlay (make-extent beg end buffer)))
  87.     (set-extent-property overlay 'overlay t)
  88.     (if front-advance
  89.     (set-extent-property overlay 'start-open t)
  90.       (set-extent-property overlay 'start-closed t))
  91.     (if rear-advance
  92.     (set-extent-property overlay 'end-closed t)
  93.       (set-extent-property overlay 'end-open t))
  94.  
  95.     overlay))
  96.  
  97. (defun move-overlay (overlay beg end &optional buffer)
  98.   "Set the endpoints of OVERLAY to BEG and END in BUFFER.
  99. If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now.
  100. If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
  101. buffer."
  102.   (check-argument-type 'overlayp overlay)
  103.   (if (null buffer)
  104.       (setq buffer (extent-object overlay)))
  105.   (if (null buffer)
  106.       (setq buffer (current-buffer)))
  107.   (check-argument-type 'bufferp buffer)
  108.   (and (= beg end)
  109.        (extent-property overlay 'evaporate)
  110.        (delete-overlay overlay))
  111.   (when (> beg end)
  112.     (setq beg (prog1 end (setq end beg))))
  113.   (set-extent-endpoints overlay beg end buffer)
  114.   overlay)
  115.  
  116. (defun delete-overlay (overlay)
  117.   "Delete the overlay OVERLAY from its buffer."
  118.   (check-argument-type 'overlayp overlay)
  119.   (detach-extent overlay)
  120.   nil)
  121.  
  122. (defun overlay-start (overlay)
  123.   "Return the position at which OVERLAY starts."
  124.   (check-argument-type 'overlayp overlay)
  125.   (extent-start-position overlay))
  126.  
  127. (defun overlay-end (overlay)
  128.   "Return the position at which OVERLAY ends."
  129.   (check-argument-type 'overlayp overlay)
  130.   (extent-end-position overlay))
  131.  
  132. (defun overlay-buffer (overlay)
  133.   "Return the buffer OVERLAY belongs to."
  134.   (check-argument-type 'overlayp overlay)
  135.   (extent-object overlay))
  136.  
  137. (defun overlay-properties (overlay)
  138.   "Return a list of the properties on OVERLAY.
  139. This is a copy of OVERLAY's plist; modifying its conses has no effect on
  140. OVERLAY."
  141.   (check-argument-type 'overlayp overlay)
  142.   (extent-properties overlay))
  143.  
  144. (defun overlays-at (pos)
  145.   "Return a list of the overlays that contain position POS."
  146.   (overlays-in pos pos))
  147.  
  148. (defun overlays-in (beg end)
  149.   "Return a list of the overlays that overlap the region BEG ... END.
  150. Overlap means that at least one character is contained within the overlay
  151. and also contained within the specified region.
  152. Empty overlays are included in the result if they are located at BEG
  153. or between BEG and END."
  154.   (mapcar-extents #'identity nil nil beg end
  155.           'all-extents-closed-open 'overlay))
  156.  
  157. (defun next-overlay-change (pos)
  158.   "Return the next position after POS where an overlay starts or ends.
  159. If there are no more overlay boundaries after POS, return (point-max)."
  160.   (let ((next (point-max))
  161.     tmp)
  162.     (map-extents
  163.      (lambda (overlay ignore)
  164.         (when (or (and (< (setq tmp (extent-start-position overlay)) next)
  165.                (> tmp pos))
  166.               (and (< (setq tmp (extent-end-position overlay)) next)
  167.                (> tmp pos)))
  168.           (setq next tmp))
  169.        nil)
  170.      nil pos nil nil 'all-extents-closed-open 'overlay)
  171.     next))
  172.  
  173. (defun previous-overlay-change (pos)
  174.   "Return the previous position before POS where an overlay starts or ends.
  175. If there are no more overlay boundaries before POS, return (point-min)."
  176.   (let ((prev (point-min))
  177.     tmp)
  178.     (map-extents
  179.      (lambda (overlay ignore)
  180.        (when (or (and (> (setq tmp (extent-end-position overlay)) prev)
  181.               (< tmp pos))
  182.          (and (> (setq tmp (extent-start-position overlay)) prev)
  183.               (< tmp pos)))
  184.      (setq prev tmp))
  185.        nil)
  186.      nil nil pos nil 'all-extents-closed-open 'overlay)
  187.     prev))
  188.  
  189. (defun overlay-lists ()
  190.   "Return a pair of lists giving all the overlays of the current buffer.
  191. The car has all the overlays before the overlay center;
  192. the cdr has all the overlays after the overlay center.
  193. Recentering overlays moves overlays between these lists.
  194. The lists you get are copies, so that changing them has no effect.
  195. However, the overlays you get are the real objects that the buffer uses."
  196.   (or (boundp 'xemacs-internal-overlay-center-pos)
  197.       (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2))))
  198.   (let ((pos xemacs-internal-overlay-center-pos)
  199.     before after)
  200.     (map-extents (lambda (overlay ignore)
  201.            (if (> pos (extent-end-position overlay))
  202.                (push overlay before)
  203.              (push overlay after))
  204.            nil)
  205.          nil nil nil nil 'all-extents-closed-open 'overlay)
  206.     (cons (nreverse before) (nreverse after))))
  207.  
  208. (defun overlay-recenter (pos)
  209.   "Recenter the overlays of the current buffer around position POS."
  210.   (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
  211.  
  212. (defun overlay-get (overlay prop)
  213.   "Get the property of overlay OVERLAY with property name PROP."
  214.   (check-argument-type 'overlayp overlay)
  215.   (let ((value (extent-property overlay prop))
  216.     category)
  217.     (if (and (null value)
  218.          (setq category (extent-property overlay 'category)))
  219.     (get category prop)
  220.       value)))
  221.  
  222. (defun overlay-put (overlay prop value)
  223.   "Set one property of overlay OVERLAY: give property PROP value VALUE."
  224.   (check-argument-type 'overlayp overlay)
  225.   (cond ((eq prop 'evaporate)
  226.      (set-extent-property overlay 'detachable value))
  227.     ((eq prop 'before-string)
  228.      (set-extent-property overlay 'begin-glyph
  229.                   (make-glyph (vector 'string :data value))))
  230.     ((eq prop 'after-string)
  231.      (set-extent-property overlay 'end-glyph
  232.                   (make-glyph (vector 'string :data value))))
  233.     ((eq prop 'local-map)
  234.      (set-extent-property overlay 'keymap value))
  235.     ((memq prop '(window insert-in-front-hooks insert-behind-hooks
  236.                  modification-hooks))
  237.      (error "cannot support overlay '%s property under XEmacs"
  238.         prop)))
  239.   (set-extent-property overlay prop value))
  240.  
  241. (provide 'overlay)
  242.  
  243. ;;; overlay.el ends here
  244.